unit uSBDUnit_TestSchedulerImpl;
interface
uses Windows, Messages, uSBDUnit_JobMill, uSBDUnit_Types, uSBD_BaseTypes,
     uSBDUnit_TestScheduler, uSBD_ServiceProvider;

type


TTestScheduler = class;
TNodeJob = class sealed( TJob)
  protected
    FScheduler: TTestScheduler;
    FCurrentNode: ITestPoint;
    FExecutionResult: TExecutionResult;

  public
    procedure   Execute_InThread;        override;
    procedure   Execute_OutOfThread;     override;
  end;


TTestScheduler = class( TSBD_RefCountedCommonBase, ITestScheduler)
  private
    [Injection] FTestEnumGetter: ITestEnumerableGetter;
    [Injection] FWindowClient:  IMainThreadedWindowedClient;
    [Injection] FClient: ITestSchedulerClient;
    [Injection] FMill: IJobMill;

    FTestEnumerable: TTestEnumerable;
    FCurrentJob: TNodeJob;
    FWindHandle: HWND;
    FMessageNum: cardinal;

    procedure OnPollOutputThread( Sender: TObject);
    procedure JobReturns( var Message1: TMessage{TJobReadyForPickup});
    procedure OnTimeOut( Sender: TObject);
    procedure ConcludeJob( Job: TNodeJob; isTimedOut: boolean);
    procedure ReEnter;
    function  isDone: boolean;

  protected
    class function  ExceptionClass: TSBDUnit_ExceptionClass;    override;

  public
    FCountDone: integer;
    FTotal: integer;
    FisDone: boolean;
    FFailCount: integer;
    FdoBreakOnFirstFail: boolean;

    procedure Run( doBreakOnFirstFail: boolean);
    procedure Clear;

    [Configuration] constructor ServiceModeCreate;
    constructor Create( TestEnumerable1: TTestEnumerable;
                        const WindowClient1:  IMainThreadedWindowedClient;
                        const Client1: ITestSchedulerClient);
  end;


procedure RegisterServices( const Registrar: IServiceProvider);
// ^-- Registers (ITestScheduler,'')

implementation




procedure RegisterServices( const Registrar: IServiceProvider);
begin
Registrar.RegisterServiceClass( TTestScheduler, ITestScheduler).Free;
end;


{ TTestScheduler }

constructor TTestScheduler.ServiceModeCreate;
begin
FMessageNum := DefaultMessageNum;
FisDone     := True;
FdoBreakOnFirstFail := True;
if Assigned( FMill) then
  FMill.OnPollOutputThread := OnPollOutputThread;
if assigned( FWindowClient) then
  FWindowClient.GetUnitTestMessageNum( FMessageNum);
FTestEnumerable := FTestEnumGetter.CreateTestEnumerable
end;





constructor TTestScheduler.Create( TestEnumerable1: TTestEnumerable;
  const WindowClient1: IMainThreadedWindowedClient;
  const Client1: ITestSchedulerClient);
begin
FTestEnumerable := TestEnumerable1;
FWindowClient   := WindowClient1;
FClient         := Client1;
FMessageNum := DefaultMessageNum;
if assigned( FWindowClient) then
  FWindowClient.GetUnitTestMessageNum( FMessageNum);
FisDone     := True
end;


procedure TTestScheduler.OnPollOutputThread( Sender: TObject);
begin
if assigned( FWindowClient) then
  FWindowClient.Breathe
end;



procedure TTestScheduler.Run( doBreakOnFirstFail: boolean);
var
  Node: ITestPoint;
begin
FdoBreakOnFirstFail := doBreakOnFirstFail;
FTotal := 0;
for Node in FTestEnumerable do
  Inc( FTotal);
FisDone := False;
FCountDone := 0;
FFailCount := 0;
for Node in FTestEnumerable do
  begin
  Node.ExecutionResult := erNull;
  Node.Status          := nsNeutral
  end;
FClient.RunStatusPotentiallyChanged;
FisDone := FCountDone >= FTotal;
ReEnter
end;


{$WARNINGS OFF}
procedure TTestScheduler.ReEnter;
var
  Node: ITestPoint;
  Ok: boolean;
  isTimedOut: boolean;
begin
for Node in FTestEnumerable do
  begin
  if not FClient.DoContinue then
    begin
    // User abort detected.
    FisDone := True;
    break
    end;
  if Node.Status <> nsNeutral then continue;
  Node.Status := nsDoing;
  Node.PreExecute;
  isTimedOut := False;
  if Node.doInBackground then
      begin
      if not assigned( FMill) then
        AcquireService( IJobMill, FMill);
      FMill.OnPollOutputThread := OnPollOutputThread;
      FCurrentJob := TNodeJob.Create( []);
      FCurrentJob.FScheduler := self;
      FCurrentJob.FCurrentNode := Node;
      FCurrentJob.FExecutionResult := erNull;
      if assigned( FWindowClient) then
        begin
        FWindHandle := FWindowClient.MainWindowHandle;
        FWindowClient.SetUnitTestHandler( JobReturns, FMessageNum, FCurrentJob);
        FWindowClient.SetTimer( OnTimeOut, Node.TimeOut, FCurrentJob);
        end;
      FMill.QueueJob( FCurrentJob);
      if assigned( FWindowClient) then
          break
        else
          begin
          isTimedOut := not FMill.WaitPop( Node.TimeOut);
          if isTimedOut then
              begin
              FMill.KillThread;
              FMill := nil;
              Ok := False
              end
            else
              Ok := Node.ExecutionResult = erPass
          end
      end
    else
      Ok := Node.Execute;
  if Ok then
      Node.ExecutionResult := erPass
    else
      Node.ExecutionResult := erFail;
  Node.PostExecute( isTimedOut);
  if Ok and (Node.ExecutionResult = erFail) then
    Ok := False; // This is the way PostExecute can signal fail.
  Node.Status := nsDone;
  Inc( FCountDone);
  if not Ok then
    inc( FFailCount);
  FCurrentJob := nil;
  FisDone := (FCountDone >= FTotal) or
             ((FFailCount >= 1) and FdoBreakOnFirstFail);
  if FisDone then break;
  if assigned( FWindowClient) then
    FWindowClient.Breathe
  end;
if FisDone then
  begin
  for Node in FTestEnumerable do
    if Node.Status <> nsDone then
      Node.Status := nsSkipped;
  FMill := nil;
  FClient.RunStatusPotentiallyChanged
  end;
end;
{$WARNINGS ON}


class function TTestScheduler.ExceptionClass: TSBDUnit_ExceptionClass;
begin
result := TSBDUnit_SchedulerException
end;

function TTestScheduler.isDone: boolean;
begin
result := FisDone
end;

procedure TTestScheduler.Clear;
begin
FCurrentJob := nil;
FCountDone  := 0;
FTotal      := 0;
FisDone     := False;
FFailCount  := 0
end;


procedure TTestScheduler.JobReturns( var Message1: TMessage);
begin
if Message1.Msg <> FMessageNum then exit;
if not FMill.WaitPop( 1000) then
  OnTimeOut( self);
Message1.Result := 1
end;


{ TNodeJob }

procedure TNodeJob.Execute_InThread;
begin
if FCurrentNode.Execute then                 // ***
    FExecutionResult := erPass
  else
    FExecutionResult := erFail
end;

procedure TTestScheduler.ConcludeJob( Job: TNodeJob; isTimedOut: boolean);
begin
if assigned( FWindowClient) then
  begin
  FWindowClient.ClearUnitTestHandler( Job);
  FWindowClient.ClearTimer( Job)
  end;
if isTimedOut then
  begin
  FMill.KillThread;
  FMill := nil
  end;
if isTimedOut or assigned( Job.FExceptionClass) then
    Job.FCurrentNode.ExecutionResult := erFail
  else
    Job.FCurrentNode.ExecutionResult := Job.FExecutionResult;
Job.FCurrentNode.PostExecute( isTimedOut);
Job.FCurrentNode.Status := nsDone;
Inc( FCountDone);
FisDone := FCountDone >= FTotal;
if Job.FCurrentNode.ExecutionResult = erFail then
  inc( FFailCount);
FCurrentJob := nil;
ReEnter
end;

procedure TNodeJob.Execute_OutOfThread;
begin
FScheduler.ConcludeJob( self, False)
end;

procedure TTestScheduler.OnTimeOut( Sender: TObject);
begin
ConcludeJob( FCurrentJob, True)
end;


end.
